home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / os2 / adaptor.zip / ADAPT.ZIP / adaptor / examples / dalib / overlap / test1.f next >
Text File  |  1993-04-27  |  1KB  |  68 lines
  1.       program overlap_test
  2.  
  3.       parameter (n=100)
  4.  
  5.       real a(n)
  6.       call cmf_random (a)
  7.       call test_left1 (a,n)
  8.       call test_right2 (a,n)
  9.       end
  10.  
  11.       subroutine test_left1 (a, n)
  12.  
  13.       integer n
  14.  
  15.       real a(n), b(n[1:0])    ! b overlaps a with [1:1]
  16.       real a1(n)
  17.       logical equal (n)
  18.       integer errors
  19.  
  20.       b = a
  21.       forall (i=1:n)
  22.          a1 (i) = b (i-1)
  23.       end forall
  24.  
  25.       a = cshift (a, 1, -1)
  26.  
  27.       equal = (a1 .eq. a)
  28.       errors = count (equal)
  29.       errors = n - errors
  30.  
  31.       print *, errors, ' Errors for left overlapping'
  32.       end
  33.  
  34.       subroutine test_right2 (a, n)
  35.  
  36.       integer n
  37.  
  38.       real a(n), b(n[0:2])    ! b overlaps a on the right side with 2
  39.       real a1(n)
  40.       logical equal (n)
  41.       integer errors
  42.  
  43. c     call print_a (a, n)
  44.  
  45.       b = a
  46.       forall (i=1:n)
  47.          a1 (i) = b (i+2)
  48.       end forall
  49.  
  50. c     call print_a (a1, n)
  51.       a = cshift (a, 1, 2)
  52. c     call print_a (a, n)
  53.  
  54.       equal = (a1 .eq. a)
  55.       errors = count (equal)
  56.       errors = n - errors
  57.  
  58.       print *, errors, ' Errors for right overlapping'
  59.       end
  60.  
  61.       subroutine print_a (a, n)
  62.       real a(n)
  63.       integer i, n
  64.       do i = 1, n
  65.         print *, 'A(',i,')  =  ', a(i)
  66.       end do
  67.       end
  68.